← Index
NYTProf Performance Profile   
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 13:01:18 2016
Reported on Fri Jan 8 13:01:36 2016

Filename(eval 1112)[/usr/share/perl5/CGI.pm:913]
StatementsExecuted 1 statements in 94µs
Eval Invoked At/usr/share/perl5/CGI.pm line 913
Line State
ments
Time
on line
Calls Time
in subs
Code
1package CGI;
2194µs%SUBS = (
3
4'URL_ENCODED'=> <<'END_OF_FUNC',
5sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
6END_OF_FUNC
7
8'MULTIPART' => <<'END_OF_FUNC',
9sub MULTIPART { 'multipart/form-data'; }
10END_OF_FUNC
11
12'SERVER_PUSH' => <<'END_OF_FUNC',
13sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
14END_OF_FUNC
15
16'new_MultipartBuffer' => <<'END_OF_FUNC',
17# Create a new multipart buffer
18sub new_MultipartBuffer {
19 my($self,$boundary,$length) = @_;
20 return MultipartBuffer->new($self,$boundary,$length);
21}
22END_OF_FUNC
23
24'read_from_client' => <<'END_OF_FUNC',
25# Read data from a file handle
26sub read_from_client {
27 my($self, $buff, $len, $offset) = @_;
28 local $^W=0; # prevent a warning
29 return $MOD_PERL
30 ? $self->r->read($$buff, $len, $offset)
31 : read(\*STDIN, $$buff, $len, $offset);
32}
33END_OF_FUNC
34
35'delete' => <<'END_OF_FUNC',
36#### Method: delete
37# Deletes the named parameter entirely.
38####
39sub delete {
40 my($self,@p) = self_or_default(@_);
41 my(@names) = rearrange([NAME],@p);
42 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
43 my %to_delete;
44 for my $name (@to_delete)
45 {
46 CORE::delete $self->{param}{$name};
47 CORE::delete $self->{'.fieldnames'}->{$name};
48 $to_delete{$name}++;
49 }
50 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
51 return;
52}
53END_OF_FUNC
54
55#### Method: import_names
56# Import all parameters into the given namespace.
57# Assumes namespace 'Q' if not specified
58####
59'import_names' => <<'END_OF_FUNC',
60sub import_names {
61 my($self,$namespace,$delete) = self_or_default(@_);
62 $namespace = 'Q' unless defined($namespace);
63 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
64 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
65 # can anyone find an easier way to do this?
66 for (keys %{"${namespace}::"}) {
67 local *symbol = "${namespace}::${_}";
68 undef $symbol;
69 undef @symbol;
70 undef %symbol;
71 }
72 }
73 my($param,@value,$var);
74 for $param ($self->param) {
75 # protect against silly names
76 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
77 $var =~ s/^(?=\d)/_/;
78 local *symbol = "${namespace}::$var";
79 @value = $self->param($param);
80 @symbol = @value;
81 $symbol = $value[0];
82 }
83}
84END_OF_FUNC
85
86#### Method: keywords
87# Keywords acts a bit differently. Calling it in a list context
88# returns the list of keywords.
89# Calling it in a scalar context gives you the size of the list.
90####
91'keywords' => <<'END_OF_FUNC',
92sub keywords {
93 my($self,@values) = self_or_default(@_);
94 # If values is provided, then we set it.
95 $self->{param}{'keywords'}=[@values] if @values;
96 my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
97 @result;
98}
99END_OF_FUNC
100
101# These are some tie() interfaces for compatibility
102# with Steve Brenner's cgi-lib.pl routines
103'Vars' => <<'END_OF_FUNC',
104sub Vars {
105 my $q = shift;
106 my %in;
107 tie(%in,CGI,$q);
108 return %in if wantarray;
109 return \%in;
110}
111END_OF_FUNC
112
113# These are some tie() interfaces for compatibility
114# with Steve Brenner's cgi-lib.pl routines
115'ReadParse' => <<'END_OF_FUNC',
116sub ReadParse {
117 local(*in);
118 if (@_) {
119 *in = $_[0];
120 } else {
121 my $pkg = caller();
122 *in=*{"${pkg}::in"};
123 }
124 tie(%in,CGI);
125 return scalar(keys %in);
126}
127END_OF_FUNC
128
129'PrintHeader' => <<'END_OF_FUNC',
130sub PrintHeader {
131 my($self) = self_or_default(@_);
132 return $self->header();
133}
134END_OF_FUNC
135
136'HtmlTop' => <<'END_OF_FUNC',
137sub HtmlTop {
138 my($self,@p) = self_or_default(@_);
139 return $self->start_html(@p);
140}
141END_OF_FUNC
142
143'HtmlBot' => <<'END_OF_FUNC',
144sub HtmlBot {
145 my($self,@p) = self_or_default(@_);
146 return $self->end_html(@p);
147}
148END_OF_FUNC
149
150'SplitParam' => <<'END_OF_FUNC',
151sub SplitParam {
152 my ($param) = @_;
153 my (@params) = split ("\0", $param);
154 return (wantarray ? @params : $params[0]);
155}
156END_OF_FUNC
157
158'MethGet' => <<'END_OF_FUNC',
159sub MethGet {
160 return request_method() eq 'GET';
161}
162END_OF_FUNC
163
164'MethPost' => <<'END_OF_FUNC',
165sub MethPost {
166 return request_method() eq 'POST';
167}
168END_OF_FUNC
169
170'MethPut' => <<'END_OF_FUNC',
171sub MethPut {
172 return request_method() eq 'PUT';
173}
174END_OF_FUNC
175
176'TIEHASH' => <<'END_OF_FUNC',
177sub TIEHASH {
178 my $class = shift;
179 my $arg = $_[0];
180 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
181 return $arg;
182 }
183 return $Q ||= $class->new(@_);
184}
185END_OF_FUNC
186
187'STORE' => <<'END_OF_FUNC',
188sub STORE {
189 my $self = shift;
190 my $tag = shift;
191 my $vals = shift;
192 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
193 $self->param(-name=>$tag,-value=>\@vals);
194}
195END_OF_FUNC
196
197'FETCH' => <<'END_OF_FUNC',
198sub FETCH {
199 return $_[0] if $_[1] eq 'CGI';
200 return undef unless defined $_[0]->param($_[1]);
201 return join("\0",$_[0]->param($_[1]));
202}
203END_OF_FUNC
204
205'FIRSTKEY' => <<'END_OF_FUNC',
206sub FIRSTKEY {
207 $_[0]->{'.iterator'}=0;
208 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
209}
210END_OF_FUNC
211
212'NEXTKEY' => <<'END_OF_FUNC',
213sub NEXTKEY {
214 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
215}
216END_OF_FUNC
217
218'EXISTS' => <<'END_OF_FUNC',
219sub EXISTS {
220 exists $_[0]->{param}{$_[1]};
221}
222END_OF_FUNC
223
224'DELETE' => <<'END_OF_FUNC',
225sub DELETE {
226 my ($self, $param) = @_;
227 my $value = $self->FETCH($param);
228 $self->delete($param);
229 return $value;
230}
231END_OF_FUNC
232
233'CLEAR' => <<'END_OF_FUNC',
234sub CLEAR {
235 %{$_[0]}=();
236}
237####
238END_OF_FUNC
239
240####
241# Append a new value to an existing query
242####
243'append' => <<'EOF',
244sub append {
245 my($self,@p) = self_or_default(@_);
246 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
247 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
248 if (@values) {
249 $self->add_parameter($name);
250 push(@{$self->{param}{$name}},@values);
251 }
252 return $self->param($name);
253}
254EOF
255
256#### Method: delete_all
257# Delete all parameters
258####
259'delete_all' => <<'EOF',
260sub delete_all {
261 my($self) = self_or_default(@_);
262 my @param = $self->param();
263 $self->delete(@param);
264}
265EOF
266
267'Delete' => <<'EOF',
268sub Delete {
269 my($self,@p) = self_or_default(@_);
270 $self->delete(@p);
271}
272EOF
273
274'Delete_all' => <<'EOF',
275sub Delete_all {
276 my($self,@p) = self_or_default(@_);
277 $self->delete_all(@p);
278}
279EOF
280
281#### Method: autoescape
282# If you want to turn off the autoescaping features,
283# call this method with undef as the argument
284'autoEscape' => <<'END_OF_FUNC',
285sub autoEscape {
286 my($self,$escape) = self_or_default(@_);
287 my $d = $self->{'escape'};
288 $self->{'escape'} = $escape;
289 $d;
290}
291END_OF_FUNC
292
293
294#### Method: version
295# Return the current version
296####
297'version' => <<'END_OF_FUNC',
298sub version {
299 return $VERSION;
300}
301END_OF_FUNC
302
303#### Method: url_param
304# Return a parameter in the QUERY_STRING, regardless of
305# whether this was a POST or a GET
306####
307'url_param' => <<'END_OF_FUNC',
308sub url_param {
309 my ($self,@p) = self_or_default(@_);
310 my $name = shift(@p);
311 return undef unless exists($ENV{QUERY_STRING});
312 unless (exists($self->{'.url_param'})) {
313 $self->{'.url_param'}={}; # empty hash
314 if ($ENV{QUERY_STRING} =~ /=/) {
315 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
316 my($param,$value);
317 for (@pairs) {
318 ($param,$value) = split('=',$_,2);
319 next if ! defined($param);
320 $param = unescape($param);
321 $value = unescape($value);
322 push(@{$self->{'.url_param'}->{$param}},$value);
323 }
324 } else {
325 my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING});
326 $self->{'.url_param'}{'keywords'} = \@keywords if @keywords;
327 }
328 }
329 return keys %{$self->{'.url_param'}} unless defined($name);
330 return () unless $self->{'.url_param'}->{$name};
331 return wantarray ? @{$self->{'.url_param'}->{$name}}
332 : $self->{'.url_param'}->{$name}->[0];
333}
334END_OF_FUNC
335
336#### Method: Dump
337# Returns a string in which all the known parameter/value
338# pairs are represented as nested lists, mainly for the purposes
339# of debugging.
340####
341'Dump' => <<'END_OF_FUNC',
342sub Dump {
343 my($self) = self_or_default(@_);
344 my($param,$value,@result);
345 return '<ul></ul>' unless $self->param;
346 push(@result,"<ul>");
347 for $param ($self->param) {
348 my($name)=$self->_maybe_escapeHTML($param);
349 push(@result,"<li><strong>$name</strong></li>");
350 push(@result,"<ul>");
351 for $value ($self->param($param)) {
352 $value = $self->_maybe_escapeHTML($value);
353 $value =~ s/\n/<br \/>\n/g;
354 push(@result,"<li>$value</li>");
355 }
356 push(@result,"</ul>");
357 }
358 push(@result,"</ul>");
359 return join("\n",@result);
360}
361END_OF_FUNC
362
363#### Method as_string
364#
365# synonym for "dump"
366####
367'as_string' => <<'END_OF_FUNC',
368sub as_string {
369 &Dump(@_);
370}
371END_OF_FUNC
372
373#### Method: save
374# Write values out to a filehandle in such a way that they can
375# be reinitialized by the filehandle form of the new() method
376####
377'save' => <<'END_OF_FUNC',
378sub save {
379 my($self,$filehandle) = self_or_default(@_);
380 $filehandle = to_filehandle($filehandle);
381 my($param);
382 local($,) = ''; # set print field separator back to a sane value
383 local($\) = ''; # set output line separator to a sane value
384 for $param ($self->param) {
385 my($escaped_param) = escape($param);
386 my($value);
387 for $value ($self->param($param)) {
388 print $filehandle "$escaped_param=",escape("$value"),"\n"
389 if length($escaped_param) or length($value);
390 }
391 }
392 for (keys %{$self->{'.fieldnames'}}) {
393 print $filehandle ".cgifields=",escape("$_"),"\n";
394 }
395 print $filehandle "=\n"; # end of record
396}
397END_OF_FUNC
398
399
400#### Method: save_parameters
401# An alias for save() that is a better name for exportation.
402# Only intended to be used with the function (non-OO) interface.
403####
404'save_parameters' => <<'END_OF_FUNC',
405sub save_parameters {
406 my $fh = shift;
407 return save(to_filehandle($fh));
408}
409END_OF_FUNC
410
411#### Method: restore_parameters
412# A way to restore CGI parameters from an initializer.
413# Only intended to be used with the function (non-OO) interface.
414####
415'restore_parameters' => <<'END_OF_FUNC',
416sub restore_parameters {
417 $Q = $CGI::DefaultClass->new(@_);
418}
419END_OF_FUNC
420
421#### Method: multipart_init
422# Return a Content-Type: style header for server-push
423# This has to be NPH on most web servers, and it is advisable to set $| = 1
424#
425# Many thanks to Ed Jordan <ed@fidalgo.net> for this
426# contribution, updated by Andrew Benham (adsb@bigfoot.com)
427####
428'multipart_init' => <<'END_OF_FUNC',
429sub multipart_init {
430 my($self,@p) = self_or_default(@_);
431 my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p);
432 if (!$boundary) {
433 $boundary = '------- =_';
434 my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
435 for (1..17) {
436 $boundary .= $chrs[rand(scalar @chrs)];
437 }
438 }
439
440 $self->{'separator'} = "$CRLF--$boundary$CRLF";
441 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
442 $type = SERVER_PUSH($boundary);
443 return $self->header(
444 -nph => 0,
445 -type => $type,
446 -charset => $charset,
447 (map { split "=", $_, 2 } @other),
448 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
449}
450END_OF_FUNC
451
452
453#### Method: multipart_start
454# Return a Content-Type: style header for server-push, start of section
455#
456# Many thanks to Ed Jordan <ed@fidalgo.net> for this
457# contribution, updated by Andrew Benham (adsb@bigfoot.com)
458####
459'multipart_start' => <<'END_OF_FUNC',
460sub multipart_start {
461 my(@header);
462 my($self,@p) = self_or_default(@_);
463 my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p);
464 $type = $type || 'text/html';
465 if ($charset) {
466 push(@header,"Content-Type: $type; charset=$charset");
467 } else {
468 push(@header,"Content-Type: $type");
469 }
470
471 # rearrange() was designed for the HTML portion, so we
472 # need to fix it up a little.
473 for (@other) {
474 # Don't use \s because of perl bug 21951
475 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
476 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
477 }
478 push(@header,@other);
479 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
480 return $header;
481}
482END_OF_FUNC
483
484
485#### Method: multipart_end
486# Return a MIME boundary separator for server-push, end of section
487#
488# Many thanks to Ed Jordan <ed@fidalgo.net> for this
489# contribution
490####
491'multipart_end' => <<'END_OF_FUNC',
492sub multipart_end {
493 my($self,@p) = self_or_default(@_);
494 return $self->{'separator'};
495}
496END_OF_FUNC
497
498
499#### Method: multipart_final
500# Return a MIME boundary separator for server-push, end of all sections
501#
502# Contributed by Andrew Benham (adsb@bigfoot.com)
503####
504'multipart_final' => <<'END_OF_FUNC',
505sub multipart_final {
506 my($self,@p) = self_or_default(@_);
507 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
508}
509END_OF_FUNC
510
511
512#### Method: header
513# Return a Content-Type: style header
514#
515####
516'header' => <<'END_OF_FUNC',
517sub header {
518 my($self,@p) = self_or_default(@_);
519 my(@header);
520
521 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
522
523 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
524 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
525 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET',
526 'EXPIRES','NPH','CHARSET',
527 'ATTACHMENT','P3P'],@p);
528
529 # Since $cookie and $p3p may be array references,
530 # we must stringify them before CR escaping is done.
531 my @cookie;
532 for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) {
533 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
534 push(@cookie,$cs) if defined $cs and $cs ne '';
535 }
536 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
537
538 # CR escaping for values, per RFC 822
539 for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
540 if (defined $header) {
541 # From RFC 822:
542 # Unfolding is accomplished by regarding CRLF immediately
543 # followed by a LWSP-char as equivalent to the LWSP-char.
544 $header =~ s/$CRLF(\s)/$1/g;
545
546 # All other uses of newlines are invalid input.
547 if ($header =~ m/$CRLF|\015|\012/) {
548 # shorten very long values in the diagnostic
549 $header = substr($header,0,72).'...' if (length $header > 72);
550 die "Invalid header value contains a newline not followed by whitespace: $header";
551 }
552 }
553 }
554
555 $nph ||= $NPH;
556
557 $type ||= 'text/html' unless defined($type);
558
559 # sets if $charset is given, gets if not
560 $charset = $self->charset( $charset );
561
562 # rearrange() was designed for the HTML portion, so we
563 # need to fix it up a little.
564 for (@other) {
565 # Don't use \s because of perl bug 21951
566 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
567 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
568 }
569
570 $type .= "; charset=$charset"
571 if $type ne ''
572 and $type !~ /\bcharset\b/
573 and defined $charset
574 and $charset ne '';
575
576 # Maybe future compatibility. Maybe not.
577 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
578 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
579 push(@header,"Server: " . &server_software()) if $nph;
580
581 push(@header,"Status: $status") if $status;
582 push(@header,"Window-Target: $target") if $target;
583 push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p;
584 # push all the cookies -- there may be several
585 push(@header,map {"Set-Cookie: $_"} @cookie);
586 # if the user indicates an expiration time, then we need
587 # both an Expires and a Date header (so that the browser is
588 # uses OUR clock)
589 push(@header,"Expires: " . expires($expires,'http'))
590 if $expires;
591 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
592 push(@header,"Pragma: no-cache") if $self->cache();
593 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
594 push(@header,map {ucfirst $_} @other);
595 push(@header,"Content-Type: $type") if $type ne '';
596 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
597 if (($MOD_PERL >= 1) && !$nph) {
598 $self->r->send_cgi_header($header);
599 return '';
600 }
601 return $header;
602}
603END_OF_FUNC
604
605#### Method: cache
606# Control whether header() will produce the no-cache
607# Pragma directive.
608####
609'cache' => <<'END_OF_FUNC',
610sub cache {
611 my($self,$new_value) = self_or_default(@_);
612 $new_value = '' unless $new_value;
613 if ($new_value ne '') {
614 $self->{'cache'} = $new_value;
615 }
616 return $self->{'cache'};
617}
618END_OF_FUNC
619
620
621#### Method: redirect
622# Return a Location: style header
623#
624####
625'redirect' => <<'END_OF_FUNC',
626sub redirect {
627 my($self,@p) = self_or_default(@_);
628 my($url,$target,$status,$cookie,$nph,@other) =
629 rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p);
630 $status = '302 Found' unless defined $status;
631 $url ||= $self->self_url;
632 my(@o);
633 for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
634 unshift(@o,
635 '-Status' => $status,
636 '-Location'=> $url,
637 '-nph' => $nph);
638 unshift(@o,'-Target'=>$target) if $target;
639 unshift(@o,'-Type'=>'');
640 my @unescaped;
641 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
642 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
643}
644END_OF_FUNC
645
646
647#### Method: start_html
648# Canned HTML header
649#
650# Parameters:
651# $title -> (optional) The title for this HTML document (-title)
652# $author -> (optional) e-mail address of the author (-author)
653# $base -> (optional) if set to true, will enter the BASE address of this document
654# for resolving relative references (-base)
655# $xbase -> (optional) alternative base at some remote location (-xbase)
656# $target -> (optional) target window to load all links into (-target)
657# $script -> (option) Javascript code (-script)
658# $no_script -> (option) Javascript <noscript> tag (-noscript)
659# $meta -> (optional) Meta information tags
660# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
661# (a scalar or array ref)
662# $style -> (optional) reference to an external style sheet
663# @other -> (optional) any other named parameters you'd like to incorporate into
664# the <body> tag.
665####
666'start_html' => <<'END_OF_FUNC',
667sub start_html {
668 my($self,@p) = &self_or_default(@_);
669 my($title,$author,$base,$xbase,$script,$noscript,
670 $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
671 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
672 META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
673
674 $self->element_id(0);
675 $self->element_tab(0);
676
677 $encoding = lc($self->charset) unless defined $encoding;
678
679 # Need to sort out the DTD before it's okay to call escapeHTML().
680 my(@result,$xml_dtd);
681 if ($dtd) {
682 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
683 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
684 } else {
685 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
686 }
687 } else {
688 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
689 }
690
691 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
692 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
693 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
694
695 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
696 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
697 $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
698 } else {
699 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
700 $DTD_PUBLIC_IDENTIFIER = $dtd;
701 }
702
703 # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
704 # call escapeHTML(). Strangely enough, the title needs to be escaped as
705 # HTML while the author needs to be escaped as a URL.
706 $title = $self->_maybe_escapeHTML($title || 'Untitled Document');
707 $author = $self->escape($author);
708
709 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
710 $lang = "" unless defined $lang;
711 $XHTML = 0;
712 }
713 else {
714 $lang = 'en-US' unless defined $lang;
715 }
716
717 my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
718 my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
719 if $XHTML && $encoding && !$declare_xml;
720
721 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
722 : ($lang ? qq(<html lang="$lang">) : "<html>")
723 . "<head><title>$title</title>");
724 if (defined $author) {
725 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
726 : "<link rev=\"made\" href=\"mailto:$author\">");
727 }
728
729 if ($base || $xbase || $target) {
730 my $href = $xbase || $self->url('-path'=>1);
731 my $t = $target ? qq/ target="$target"/ : '';
732 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
733 }
734
735 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
736 for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
737 : qq(<meta name="$_" content="$meta->{$_}">)); }
738 }
739
740 my $meta_bits_set = 0;
741 if( $head ) {
742 if( ref $head ) {
743 push @result, @$head;
744 $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
745 }
746 else {
747 push @result, $head;
748 $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
749 }
750 }
751
752 # handle the infrequently-used -style and -script parameters
753 push(@result,$self->_style($style)) if defined $style;
754 push(@result,$self->_script($script)) if defined $script;
755 push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
756
757 # handle -noscript parameter
758 push(@result,<<END) if $noscript;
759<noscript>
760$noscript
761</noscript>
762END
763 ;
764 my($other) = @other ? " @other" : '';
765 push(@result,"</head>\n<body$other>\n");
766 return join("\n",@result);
767}
768END_OF_FUNC
769
770### Method: _style
771# internal method for generating a CSS style section
772####
773'_style' => <<'END_OF_FUNC',
774sub _style {
775 my ($self,$style) = @_;
776 my (@result);
777
778 my $type = 'text/css';
779 my $rel = 'stylesheet';
780
781
782 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
783 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
784
785 my @s = ref($style) eq 'ARRAY' ? @$style : $style;
786 my $other = '';
787
788 for my $s (@s) {
789 if (ref($s)) {
790 my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
791 rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
792 ('-foo'=>'bar',
793 ref($s) eq 'ARRAY' ? @$s : %$s));
794 my $type = defined $stype ? $stype : 'text/css';
795 my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
796 $other = "@other" if @other;
797
798 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
799 { # If it is, push a LINK tag for each one
800 for $src (@$src)
801 {
802 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
803 : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
804 }
805 }
806 else
807 { # Otherwise, push the single -src, if it exists.
808 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
809 : qq(<link rel="$rel" type="$type" href="$src"$other>)
810 ) if $src;
811 }
812 if ($verbatim) {
813 my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
814 push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
815 }
816 if ($code) {
817 my @c = ref($code) eq 'ARRAY' ? @$code : $code;
818 push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
819 }
820
821 } else {
822 my $src = $s;
823 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
824 : qq(<link rel="$rel" type="$type" href="$src"$other>));
825 }
826 }
827 @result;
828}
829END_OF_FUNC
830
831'_script' => <<'END_OF_FUNC',
832sub _script {
833 my ($self,$script) = @_;
834 my (@result);
835
836 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
837 for $script (@scripts) {
838 my($src,$code,$language,$charset);
839 if (ref($script)) { # script is a hash
840 ($src,$code,$type,$charset) =
841 rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'],
842 '-foo'=>'bar', # a trick to allow the '-' to be omitted
843 ref($script) eq 'ARRAY' ? @$script : %$script);
844 $type ||= 'text/javascript';
845 unless ($type =~ m!\w+/\w+!) {
846 $type =~ s/[\d.]+$//;
847 $type = "text/$type";
848 }
849 } else {
850 ($src,$code,$type,$charset) = ('',$script, 'text/javascript', '');
851 }
852
853 my $comment = '//'; # javascript by default
854 $comment = '#' if $type=~/perl|tcl/i;
855 $comment = "'" if $type=~/vbscript/i;
856
857 my ($cdata_start,$cdata_end);
858 if ($XHTML) {
859 $cdata_start = "$comment<![CDATA[\n";
860 $cdata_end .= "\n$comment]]>";
861 } else {
862 $cdata_start = "\n<!-- Hide script\n";
863 $cdata_end = $comment;
864 $cdata_end .= " End script hiding -->\n";
865 }
866 my(@satts);
867 push(@satts,'src'=>$src) if $src;
868 push(@satts,'type'=>$type);
869 push(@satts,'charset'=>$charset) if ($src && $charset);
870 $code = $cdata_start . $code . $cdata_end if defined $code;
871 push(@result,$self->script({@satts},$code || ''));
872 }
873 @result;
874}
875END_OF_FUNC
876
877#### Method: end_html
878# End an HTML document.
879# Trivial method for completeness. Just returns "</body>"
880####
881'end_html' => <<'END_OF_FUNC',
882sub end_html {
883 return "\n</body>\n</html>";
884}
885END_OF_FUNC
886
887
888################################
889# METHODS USED IN BUILDING FORMS
890################################
891
892#### Method: isindex
893# Just prints out the isindex tag.
894# Parameters:
895# $action -> optional URL of script to run
896# Returns:
897# A string containing a <isindex> tag
898'isindex' => <<'END_OF_FUNC',
899sub isindex {
900 my($self,@p) = self_or_default(@_);
901 my($action,@other) = rearrange([ACTION],@p);
902 $action = qq/ action="$action"/ if $action;
903 my($other) = @other ? " @other" : '';
904 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
905}
906END_OF_FUNC
907
908
909#### Method: start_form
910# Start a form
911# Parameters:
912# $method -> optional submission method to use (GET or POST)
913# $action -> optional URL of script to run
914# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
915'start_form' => <<'END_OF_FUNC',
916sub start_form {
917 my($self,@p) = self_or_default(@_);
918
919 my($method,$action,$enctype,@other) =
920 rearrange([METHOD,ACTION,ENCTYPE],@p);
921
922 $method = $self->_maybe_escapeHTML(lc($method || 'post'));
923
924 if( $XHTML ){
925 $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
926 }else{
927 $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
928 }
929
930 if (defined $action) {
931 $action = $self->_maybe_escapeHTML($action);
932 }
933 else {
934 $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
935 }
936 $action = qq(action="$action");
937 my($other) = @other ? " @other" : '';
938 $self->{'.parametersToAdd'}={};
939 return qq/<form method="$method" $action enctype="$enctype"$other>/;
940}
941END_OF_FUNC
942
943#### Method: start_multipart_form
944'start_multipart_form' => <<'END_OF_FUNC',
945sub start_multipart_form {
946 my($self,@p) = self_or_default(@_);
947 if (defined($p[0]) && substr($p[0],0,1) eq '-') {
948 return $self->start_form(-enctype=>&MULTIPART,@p);
949 } else {
950 my($method,$action,@other) =
951 rearrange([METHOD,ACTION],@p);
952 return $self->start_form($method,$action,&MULTIPART,@other);
953 }
954}
955END_OF_FUNC
956
- -
959#### Method: end_form
960# End a form
961# Note: This repeated below under the older name.
962'end_form' => <<'END_OF_FUNC',
963sub end_form {
964 my($self,@p) = self_or_default(@_);
965 if ( $NOSTICKY ) {
966 return wantarray ? ("</form>") : "\n</form>";
967 } else {
968 if (my @fields = $self->get_fields) {
969 return wantarray ? ("<div>",@fields,"</div>","</form>")
970 : "<div>".(join '',@fields)."</div>\n</form>";
971 } else {
972 return "</form>";
973 }
974 }
975}
976END_OF_FUNC
977
978
979#### Method: end_multipart_form
980# end a multipart form
981'end_multipart_form' => <<'END_OF_FUNC',
982sub end_multipart_form {
983 &end_form;
984}
985END_OF_FUNC
986
987
988'_textfield' => <<'END_OF_FUNC',
989sub _textfield {
990 my($self,$tag,@p) = self_or_default(@_);
991 my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
992 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
993
994 my $current = $override ? $default :
995 (defined($self->param($name)) ? $self->param($name) : $default);
996
997 $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
998 $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
999 my($s) = defined($size) ? qq/ size="$size"/ : '';
1000 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1001 my($other) = @other ? " @other" : '';
1002 # this entered at cristy's request to fix problems with file upload fields
1003 # and WebTV -- not sure it won't break stuff
1004 my($value) = $current ne '' ? qq(value="$current") : '';
1005 $tabindex = $self->element_tab($tabindex);
1006 return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
1007 : qq(<input type="$tag" name="$name" $value$s$m$other>);
1008}
1009END_OF_FUNC
1010
1011#### Method: textfield
1012# Parameters:
1013# $name -> Name of the text field
1014# $default -> Optional default value of the field if not
1015# already defined.
1016# $size -> Optional width of field in characaters.
1017# $maxlength -> Optional maximum number of characters.
1018# Returns:
1019# A string containing a <input type="text"> field
1020#
1021'textfield' => <<'END_OF_FUNC',
1022sub textfield {
1023 my($self,@p) = self_or_default(@_);
1024 $self->_textfield('text',@p);
1025}
1026END_OF_FUNC
1027
1028
1029#### Method: filefield
1030# Parameters:
1031# $name -> Name of the file upload field
1032# $size -> Optional width of field in characaters.
1033# $maxlength -> Optional maximum number of characters.
1034# Returns:
1035# A string containing a <input type="file"> field
1036#
1037'filefield' => <<'END_OF_FUNC',
1038sub filefield {
1039 my($self,@p) = self_or_default(@_);
1040 $self->_textfield('file',@p);
1041}
1042END_OF_FUNC
1043
1044
1045#### Method: password
1046# Create a "secret password" entry field
1047# Parameters:
1048# $name -> Name of the field
1049# $default -> Optional default value of the field if not
1050# already defined.
1051# $size -> Optional width of field in characters.
1052# $maxlength -> Optional maximum characters that can be entered.
1053# Returns:
1054# A string containing a <input type="password"> field
1055#
1056'password_field' => <<'END_OF_FUNC',
1057sub password_field {
1058 my ($self,@p) = self_or_default(@_);
1059 $self->_textfield('password',@p);
1060}
1061END_OF_FUNC
1062
1063#### Method: textarea
1064# Parameters:
1065# $name -> Name of the text field
1066# $default -> Optional default value of the field if not
1067# already defined.
1068# $rows -> Optional number of rows in text area
1069# $columns -> Optional number of columns in text area
1070# Returns:
1071# A string containing a <textarea></textarea> tag
1072#
1073'textarea' => <<'END_OF_FUNC',
1074sub textarea {
1075 my($self,@p) = self_or_default(@_);
1076 my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1077 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
1078
1079 my($current)= $override ? $default :
1080 (defined($self->param($name)) ? $self->param($name) : $default);
1081
1082 $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
1083 $current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
1084 my($r) = $rows ? qq/ rows="$rows"/ : '';
1085 my($c) = $cols ? qq/ cols="$cols"/ : '';
1086 my($other) = @other ? " @other" : '';
1087 $tabindex = $self->element_tab($tabindex);
1088 return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
1089}
1090END_OF_FUNC
1091
1092
1093#### Method: button
1094# Create a javascript button.
1095# Parameters:
1096# $name -> (optional) Name for the button. (-name)
1097# $value -> (optional) Value of the button when selected (and visible name) (-value)
1098# $onclick -> (optional) Text of the JavaScript to run when the button is
1099# clicked.
1100# Returns:
1101# A string containing a <input type="button"> tag
1102####
1103'button' => <<'END_OF_FUNC',
1104sub button {
1105 my($self,@p) = self_or_default(@_);
1106
1107 my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
1108 [ONCLICK,SCRIPT],TABINDEX],@p);
1109
1110 $label=$self->_maybe_escapeHTML($label);
1111 $value=$self->_maybe_escapeHTML($value,1);
1112 $script=$self->_maybe_escapeHTML($script);
1113
1114 $script ||= '';
1115
1116 my($name) = '';
1117 $name = qq/ name="$label"/ if $label;
1118 $value = $value || $label;
1119 my($val) = '';
1120 $val = qq/ value="$value"/ if $value;
1121 $script = qq/ onclick="$script"/ if $script;
1122 my($other) = @other ? " @other" : '';
1123 $tabindex = $self->element_tab($tabindex);
1124 return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
1125 : qq(<input type="button"$name$val$script$other>);
1126}
1127END_OF_FUNC
1128
1129
1130#### Method: submit
1131# Create a "submit query" button.
1132# Parameters:
1133# $name -> (optional) Name for the button.
1134# $value -> (optional) Value of the button when selected (also doubles as label).
1135# $label -> (optional) Label printed on the button(also doubles as the value).
1136# Returns:
1137# A string containing a <input type="submit"> tag
1138####
1139'submit' => <<'END_OF_FUNC',
1140sub submit {
1141 my($self,@p) = self_or_default(@_);
1142
1143 my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
1144
1145 $label=$self->_maybe_escapeHTML($label);
1146 $value=$self->_maybe_escapeHTML($value,1);
1147
1148 my $name = $NOSTICKY ? '' : 'name=".submit" ';
1149 $name = qq/name="$label" / if defined($label);
1150 $value = defined($value) ? $value : $label;
1151 my $val = '';
1152 $val = qq/value="$value" / if defined($value);
1153 $tabindex = $self->element_tab($tabindex);
1154 my($other) = @other ? "@other " : '';
1155 return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
1156 : qq(<input type="submit" $name$val$other>);
1157}
1158END_OF_FUNC
1159
1160
1161#### Method: reset
1162# Create a "reset" button.
1163# Parameters:
1164# $name -> (optional) Name for the button.
1165# Returns:
1166# A string containing a <input type="reset"> tag
1167####
1168'reset' => <<'END_OF_FUNC',
1169sub reset {
1170 my($self,@p) = self_or_default(@_);
1171 my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
1172 $label=$self->_maybe_escapeHTML($label);
1173 $value=$self->_maybe_escapeHTML($value,1);
1174 my ($name) = ' name=".reset"';
1175 $name = qq/ name="$label"/ if defined($label);
1176 $value = defined($value) ? $value : $label;
1177 my($val) = '';
1178 $val = qq/ value="$value"/ if defined($value);
1179 my($other) = @other ? " @other" : '';
1180 $tabindex = $self->element_tab($tabindex);
1181 return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
1182 : qq(<input type="reset"$name$val$other>);
1183}
1184END_OF_FUNC
1185
1186
1187#### Method: defaults
1188# Create a "defaults" button.
1189# Parameters:
1190# $name -> (optional) Name for the button.
1191# Returns:
1192# A string containing a <input type="submit" name=".defaults"> tag
1193#
1194# Note: this button has a special meaning to the initialization script,
1195# and tells it to ERASE the current query string so that your defaults
1196# are used again!
1197####
1198'defaults' => <<'END_OF_FUNC',
1199sub defaults {
1200 my($self,@p) = self_or_default(@_);
1201
1202 my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
1203
1204 $label=$self->_maybe_escapeHTML($label,1);
1205 $label = $label || "Defaults";
1206 my($value) = qq/ value="$label"/;
1207 my($other) = @other ? " @other" : '';
1208 $tabindex = $self->element_tab($tabindex);
1209 return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
1210 : qq/<input type="submit" NAME=".defaults"$value$other>/;
1211}
1212END_OF_FUNC
1213
1214
1215#### Method: comment
1216# Create an HTML <!-- comment -->
1217# Parameters: a string
1218'comment' => <<'END_OF_FUNC',
1219sub comment {
1220 my($self,@p) = self_or_CGI(@_);
1221 return "<!-- @p -->";
1222}
1223END_OF_FUNC
1224
1225#### Method: checkbox
1226# Create a checkbox that is not logically linked to any others.
1227# The field value is "on" when the button is checked.
1228# Parameters:
1229# $name -> Name of the checkbox
1230# $checked -> (optional) turned on by default if true
1231# $value -> (optional) value of the checkbox, 'on' by default
1232# $label -> (optional) a user-readable label printed next to the box.
1233# Otherwise the checkbox name is used.
1234# Returns:
1235# A string containing a <input type="checkbox"> field
1236####
1237'checkbox' => <<'END_OF_FUNC',
1238sub checkbox {
1239 my($self,@p) = self_or_default(@_);
1240
1241 my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
1242 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
1243 [OVERRIDE,FORCE],TABINDEX],@p);
1244
1245 $value = defined $value ? $value : 'on';
1246
1247 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1248 defined $self->param($name))) {
1249 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
1250 } else {
1251 $checked = $self->_checked($checked);
1252 }
1253 my($the_label) = defined $label ? $label : $name;
1254 $name = $self->_maybe_escapeHTML($name);
1255 $value = $self->_maybe_escapeHTML($value,1);
1256 $the_label = $self->_maybe_escapeHTML($the_label);
1257 my($other) = @other ? "@other " : '';
1258 $tabindex = $self->element_tab($tabindex);
1259 $self->register_parameter($name);
1260 return $XHTML ? CGI::label($labelattributes,
1261 qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
1262 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
1263}
1264END_OF_FUNC
1265
- -
1268# Escape HTML
1269'escapeHTML' => <<'END_OF_FUNC',
1270sub escapeHTML {
1271 # hack to work around earlier hacks
1272 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1273 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
1274 return undef unless defined($toencode);
1275 $toencode =~ s{&}{&amp;}gso;
1276 $toencode =~ s{<}{&lt;}gso;
1277 $toencode =~ s{>}{&gt;}gso;
1278 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
1279 # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
1280 # <http://validator.w3.org/docs/errors.html#bad-entity> /
1281 # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
1282 $toencode =~ s{"}{&#34;}gso;
1283 }
1284 else {
1285 $toencode =~ s{"}{&quot;}gso;
1286 }
1287
1288 # Handle bug in some browsers with Latin charsets
1289 if ($self->{'.charset'}
1290 && (uc($self->{'.charset'}) eq 'ISO-8859-1'
1291 || uc($self->{'.charset'}) eq 'WINDOWS-1252')) {
1292 $toencode =~ s{'}{&#39;}gso;
1293 $toencode =~ s{\x8b}{&#8249;}gso;
1294 $toencode =~ s{\x9b}{&#8250;}gso;
1295 if (defined $newlinestoo && $newlinestoo) {
1296 $toencode =~ s{\012}{&#10;}gso;
1297 $toencode =~ s{\015}{&#13;}gso;
1298 }
1299 }
1300 return $toencode;
1301}
1302END_OF_FUNC
1303
1304# unescape HTML -- used internally
1305'unescapeHTML' => <<'END_OF_FUNC',
1306sub unescapeHTML {
1307 # hack to work around earlier hacks
1308 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1309 my ($self,$string) = CGI::self_or_default(@_);
1310 return undef unless defined($string);
1311 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
1312 : 1;
1313 # thanks to Randal Schwartz for the correct solution to this one
1314 $string=~ s[&([^\s&]*?);]{
1315 local $_ = $1;
1316 /^amp$/i ? "&" :
1317 /^quot$/i ? '"' :
1318 /^gt$/i ? ">" :
1319 /^lt$/i ? "<" :
1320 /^#(\d+)$/ && $latin ? chr($1) :
1321 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
1322 "&$_;"
1323 }gex;
1324 return $string;
1325}
1326END_OF_FUNC
1327
1328# Internal procedure - don't use
1329'_tableize' => <<'END_OF_FUNC',
1330sub _tableize {
1331 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1332 my @rowheaders = $rowheaders ? @$rowheaders : ();
1333 my @colheaders = $colheaders ? @$colheaders : ();
1334 my($result);
1335
1336 if (defined($columns)) {
1337 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1338 }
1339 if (defined($rows)) {
1340 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1341 }
1342
1343 # rearrange into a pretty table
1344 $result = "<table>";
1345 my($row,$column);
1346 unshift(@colheaders,'') if @colheaders && @rowheaders;
1347 $result .= "<tr>" if @colheaders;
1348 for (@colheaders) {
1349 $result .= "<th>$_</th>";
1350 }
1351 for ($row=0;$row<$rows;$row++) {
1352 $result .= "<tr>";
1353 $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
1354 for ($column=0;$column<$columns;$column++) {
1355 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
1356 if defined($elements[$column*$rows + $row]);
1357 }
1358 $result .= "</tr>";
1359 }
1360 $result .= "</table>";
1361 return $result;
1362}
1363END_OF_FUNC
1364
1365
1366#### Method: radio_group
1367# Create a list of logically-linked radio buttons.
1368# Parameters:
1369# $name -> Common name for all the buttons.
1370# $values -> A pointer to a regular array containing the
1371# values for each button in the group.
1372# $default -> (optional) Value of the button to turn on by default. Pass '-'
1373# to turn _nothing_ on.
1374# $linebreak -> (optional) Set to true to place linebreaks
1375# between the buttons.
1376# $labels -> (optional)
1377# A pointer to a hash of labels to print next to each checkbox
1378# in the form $label{'value'}="Long explanatory label".
1379# Otherwise the provided values are used as the labels.
1380# Returns:
1381# An ARRAY containing a series of <input type="radio"> fields
1382####
1383'radio_group' => <<'END_OF_FUNC',
1384sub radio_group {
1385 my($self,@p) = self_or_default(@_);
1386 $self->_box_group('radio',@p);
1387}
1388END_OF_FUNC
1389
1390#### Method: checkbox_group
1391# Create a list of logically-linked checkboxes.
1392# Parameters:
1393# $name -> Common name for all the check boxes
1394# $values -> A pointer to a regular array containing the
1395# values for each checkbox in the group.
1396# $defaults -> (optional)
1397# 1. If a pointer to a regular array of checkbox values,
1398# then this will be used to decide which
1399# checkboxes to turn on by default.
1400# 2. If a scalar, will be assumed to hold the
1401# value of a single checkbox in the group to turn on.
1402# $linebreak -> (optional) Set to true to place linebreaks
1403# between the buttons.
1404# $labels -> (optional)
1405# A pointer to a hash of labels to print next to each checkbox
1406# in the form $label{'value'}="Long explanatory label".
1407# Otherwise the provided values are used as the labels.
1408# Returns:
1409# An ARRAY containing a series of <input type="checkbox"> fields
1410####
1411
1412'checkbox_group' => <<'END_OF_FUNC',
1413sub checkbox_group {
1414 my($self,@p) = self_or_default(@_);
1415 $self->_box_group('checkbox',@p);
1416}
1417END_OF_FUNC
1418
1419'_box_group' => <<'END_OF_FUNC',
1420sub _box_group {
1421 my $self = shift;
1422 my $box_type = shift;
1423
1424 my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
1425 $attributes,$rows,$columns,$rowheaders,$colheaders,
1426 $override,$nolabels,$tabindex,$disabled,@other) =
1427 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
1428 ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
1429 [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
1430 ],@_);
1431
1432
1433 my($result,$checked,@elements,@values);
1434
1435 @values = $self->_set_values_and_labels($values,\$labels,$name);
1436 my %checked = $self->previous_or_default($name,$defaults,$override);
1437
1438 # If no check array is specified, check the first by default
1439 $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
1440
1441 $name=$self->_maybe_escapeHTML($name);
1442
1443 my %tabs = ();
1444 if ($TABINDEX && $tabindex) {
1445 if (!ref $tabindex) {
1446 $self->element_tab($tabindex);
1447 } elsif (ref $tabindex eq 'ARRAY') {
1448 %tabs = map {$_=>$self->element_tab} @$tabindex;
1449 } elsif (ref $tabindex eq 'HASH') {
1450 %tabs = %$tabindex;
1451 }
1452 }
1453 %tabs = map {$_=>$self->element_tab} @values unless %tabs;
1454 my $other = @other ? "@other " : '';
1455 my $radio_checked;
1456
1457 # for disabling groups of radio/checkbox buttons
1458 my %disabled;
1459 for (@{$disabled}) {
1460 $disabled{$_}=1;
1461 }
1462
1463 for (@values) {
1464 my $disable="";
1465 if ($disabled{$_}) {
1466 $disable="disabled='1'";
1467 }
1468
1469 my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
1470 : $checked{$_});
1471 my($break);
1472 if ($linebreak) {
1473 $break = $XHTML ? "<br />" : "<br>";
1474 }
1475 else {
1476 $break = '';
1477 }
1478 my($label)='';
1479 unless (defined($nolabels) && $nolabels) {
1480 $label = $_;
1481 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1482 $label = $self->_maybe_escapeHTML($label,1);
1483 $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
1484 }
1485 my $attribs = $self->_set_attributes($_, $attributes);
1486 my $tab = $tabs{$_};
1487 $_=$self->_maybe_escapeHTML($_);
1488
1489 if ($XHTML) {
1490 push @elements,
1491 CGI::label($labelattributes,
1492 qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
1493 } else {
1494 push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/);
1495 }
1496 }
1497 $self->register_parameter($name);
1498 return wantarray ? @elements : "@elements"
1499 unless defined($columns) || defined($rows);
1500 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1501}
1502END_OF_FUNC
1503
1504
1505#### Method: popup_menu
1506# Create a popup menu.
1507# Parameters:
1508# $name -> Name for all the menu
1509# $values -> A pointer to a regular array containing the
1510# text of each menu item.
1511# $default -> (optional) Default item to display
1512# $labels -> (optional)
1513# A pointer to a hash of labels to print next to each checkbox
1514# in the form $label{'value'}="Long explanatory label".
1515# Otherwise the provided values are used as the labels.
1516# Returns:
1517# A string containing the definition of a popup menu.
1518####
1519'popup_menu' => <<'END_OF_FUNC',
1520sub popup_menu {
1521 my($self,@p) = self_or_default(@_);
1522
1523 my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
1524 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
1525 ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1526 my($result,%selected);
1527
1528 if (!$override && defined($self->param($name))) {
1529 $selected{$self->param($name)}++;
1530 } elsif (defined $default) {
1531 %selected = map {$_=>1} ref($default) eq 'ARRAY'
1532 ? @$default
1533 : $default;
1534 }
1535 $name=$self->_maybe_escapeHTML($name);
1536 # RT #30057 - ignore -multiple, if you need this
1537 # then use scrolling_list
1538 @other = grep { $_ !~ /^multiple=/i } @other;
1539 my($other) = @other ? " @other" : '';
1540
1541 my(@values);
1542 @values = $self->_set_values_and_labels($values,\$labels,$name);
1543 $tabindex = $self->element_tab($tabindex);
1544 $name = q{} if ! defined $name;
1545 $result = qq/<select name="$name" $tabindex$other>\n/;
1546 for (@values) {
1547 if (/<optgroup/) {
1548 for my $v (split(/\n/)) {
1549 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1550 for my $selected (keys %selected) {
1551 $v =~ s/(value="\Q$selected\E")/$selectit $1/;
1552 }
1553 $result .= "$v\n";
1554 }
1555 }
1556 else {
1557 my $attribs = $self->_set_attributes($_, $attributes);
1558 my($selectit) = $self->_selected($selected{$_});
1559 my($label) = $_;
1560 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1561 my($value) = $self->_maybe_escapeHTML($_);
1562 $label = $self->_maybe_escapeHTML($label,1);
1563 $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
1564 }
1565 }
1566
1567 $result .= "</select>";
1568 return $result;
1569}
1570END_OF_FUNC
1571
1572
1573#### Method: optgroup
1574# Create a optgroup.
1575# Parameters:
1576# $name -> Label for the group
1577# $values -> A pointer to a regular array containing the
1578# values for each option line in the group.
1579# $labels -> (optional)
1580# A pointer to a hash of labels to print next to each item
1581# in the form $label{'value'}="Long explanatory label".
1582# Otherwise the provided values are used as the labels.
1583# $labeled -> (optional)
1584# A true value indicates the value should be used as the label attribute
1585# in the option elements.
1586# The label attribute specifies the option label presented to the user.
1587# This defaults to the content of the <option> element, but the label
1588# attribute allows authors to more easily use optgroup without sacrificing
1589# compatibility with browsers that do not support option groups.
1590# $novals -> (optional)
1591# A true value indicates to suppress the val attribute in the option elements
1592# Returns:
1593# A string containing the definition of an option group.
1594####
1595'optgroup' => <<'END_OF_FUNC',
1596sub optgroup {
1597 my($self,@p) = self_or_default(@_);
1598 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
1599 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
1600
1601 my($result,@values);
1602 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
1603 my($other) = @other ? " @other" : '';
1604
1605 $name = $self->_maybe_escapeHTML($name) || q{};
1606 $result = qq/<optgroup label="$name"$other>\n/;
1607 for (@values) {
1608 if (/<optgroup/) {
1609 for (split(/\n/)) {
1610 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1611 s/(value="$selected")/$selectit $1/ if defined $selected;
1612 $result .= "$_\n";
1613 }
1614 }
1615 else {
1616 my $attribs = $self->_set_attributes($_, $attributes);
1617 my($label) = $_;
1618 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1619 $label=$self->_maybe_escapeHTML($label);
1620 my($value)=$self->_maybe_escapeHTML($_,1);
1621 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
1622 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
1623 : $novals ? "<option$attribs>$label</option>\n"
1624 : "<option$attribs value=\"$value\">$label</option>\n";
1625 }
1626 }
1627 $result .= "</optgroup>";
1628 return $result;
1629}
1630END_OF_FUNC
1631
1632
1633#### Method: scrolling_list
1634# Create a scrolling list.
1635# Parameters:
1636# $name -> name for the list
1637# $values -> A pointer to a regular array containing the
1638# values for each option line in the list.
1639# $defaults -> (optional)
1640# 1. If a pointer to a regular array of options,
1641# then this will be used to decide which
1642# lines to turn on by default.
1643# 2. Otherwise holds the value of the single line to turn on.
1644# $size -> (optional) Size of the list.
1645# $multiple -> (optional) If set, allow multiple selections.
1646# $labels -> (optional)
1647# A pointer to a hash of labels to print next to each checkbox
1648# in the form $label{'value'}="Long explanatory label".
1649# Otherwise the provided values are used as the labels.
1650# Returns:
1651# A string containing the definition of a scrolling list.
1652####
1653'scrolling_list' => <<'END_OF_FUNC',
1654sub scrolling_list {
1655 my($self,@p) = self_or_default(@_);
1656 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
1657 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1658 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1659
1660 my($result,@values);
1661 @values = $self->_set_values_and_labels($values,\$labels,$name);
1662
1663 $size = $size || scalar(@values);
1664
1665 my(%selected) = $self->previous_or_default($name,$defaults,$override);
1666
1667 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
1668 my($has_size) = $size ? qq/ size="$size"/: '';
1669 my($other) = @other ? " @other" : '';
1670
1671 $name=$self->_maybe_escapeHTML($name);
1672 $tabindex = $self->element_tab($tabindex);
1673 $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
1674 for (@values) {
1675 if (/<optgroup/) {
1676 for my $v (split(/\n/)) {
1677 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1678 for my $selected (keys %selected) {
1679 $v =~ s/(value="$selected")/$selectit $1/;
1680 }
1681 $result .= "$v\n";
1682 }
1683 }
1684 else {
1685 my $attribs = $self->_set_attributes($_, $attributes);
1686 my($selectit) = $self->_selected($selected{$_});
1687 my($label) = $_;
1688 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1689 my($value) = $self->_maybe_escapeHTML($_);
1690 $label = $self->_maybe_escapeHTML($label,1);
1691 $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
1692 }
1693 }
1694
1695 $result .= "</select>";
1696 $self->register_parameter($name);
1697 return $result;
1698}
1699END_OF_FUNC
1700
1701
1702#### Method: hidden
1703# Parameters:
1704# $name -> Name of the hidden field
1705# @default -> (optional) Initial values of field (may be an array)
1706# or
1707# $default->[initial values of field]
1708# Returns:
1709# A string containing a <input type="hidden" name="name" value="value">
1710####
1711'hidden' => <<'END_OF_FUNC',
1712sub hidden {
1713 my($self,@p) = self_or_default(@_);
1714
1715 # this is the one place where we departed from our standard
1716 # calling scheme, so we have to special-case (darn)
1717 my(@result,@value);
1718 my($name,$default,$override,@other) =
1719 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1720
1721 my $do_override = 0;
1722 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
1723 @value = ref($default) ? @{$default} : $default;
1724 $do_override = $override;
1725 } else {
1726 for ($default,$override,@other) {
1727 push(@value,$_) if defined($_);
1728 }
1729 undef @other;
1730 }
1731
1732 # use previous values if override is not set
1733 my @prev = $self->param($name);
1734 @value = @prev if !$do_override && @prev;
1735
1736 $name=$self->_maybe_escapeHTML($name);
1737 for (@value) {
1738 $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
1739 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
1740 : qq(<input type="hidden" name="$name" value="$_" @other>);
1741 }
1742 return wantarray ? @result : join('',@result);
1743}
1744END_OF_FUNC
1745
1746
1747#### Method: image_button
1748# Parameters:
1749# $name -> Name of the button
1750# $src -> URL of the image source
1751# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1752# Returns:
1753# A string containing a <input type="image" name="name" src="url" align="alignment">
1754####
1755'image_button' => <<'END_OF_FUNC',
1756sub image_button {
1757 my($self,@p) = self_or_default(@_);
1758
1759 my($name,$src,$alignment,@other) =
1760 rearrange([NAME,SRC,ALIGN],@p);
1761
1762 my($align) = $alignment ? " align=\L\"$alignment\"" : '';
1763 my($other) = @other ? " @other" : '';
1764 $name=$self->_maybe_escapeHTML($name);
1765 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
1766 : qq/<input type="image" name="$name" src="$src"$align$other>/;
1767}
1768END_OF_FUNC
1769
1770
1771#### Method: self_url
1772# Returns a URL containing the current script and all its
1773# param/value pairs arranged as a query. You can use this
1774# to create a link that, when selected, will reinvoke the
1775# script with all its state information preserved.
1776####
1777'self_url' => <<'END_OF_FUNC',
1778sub self_url {
1779 my($self,@p) = self_or_default(@_);
1780 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
1781}
1782END_OF_FUNC
1783
1784
1785# This is provided as a synonym to self_url() for people unfortunate
1786# enough to have incorporated it into their programs already!
1787'state' => <<'END_OF_FUNC',
1788sub state {
1789 &self_url;
1790}
1791END_OF_FUNC
1792
1793
1794#### Method: url
1795# Like self_url, but doesn't return the query string part of
1796# the URL.
1797####
1798'url' => <<'END_OF_FUNC',
1799sub url {
1800 my($self,@p) = self_or_default(@_);
1801 my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
1802 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
1803 my $url = '';
1804 $full++ if $base || !($relative || $absolute);
1805 $rewrite++ unless defined $rewrite;
1806
1807 my $path = $self->path_info;
1808 my $script_name = $self->script_name;
1809 my $request_uri = $self->request_uri || '';
1810 my $query_str = $query ? $self->query_string : '';
1811
1812 $request_uri =~ s/\?.*$//s; # remove query string
1813 $request_uri = unescape($request_uri);
1814
1815 my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
1816 $uri =~ s/\?.*$//s; # remove query string
1817
1818 if ( defined( $ENV{PATH_INFO} ) ) {
1819 # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out
1820 # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO
1821 $uri =~ s/\Q$ENV{PATH_INFO}\E$//
1822 if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} );
1823 }
1824
1825 if ($full) {
1826 my $protocol = $self->protocol();
1827 $url = "$protocol://";
1828 my $vh = http('x_forwarded_host') || http('host') || '';
1829 $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has
1830 # passed through multiple reverse proxies. Take the last one.
1831 $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
1832
1833 $url .= $vh || server_name();
1834
1835 my $port = $self->virtual_port;
1836
1837 # add the port to the url unless it's the protocol's default port
1838 $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
1839 or (lc($protocol) eq 'https' && $port == 443);
1840
1841 return $url if $base;
1842
1843 $url .= $uri;
1844 } elsif ($relative) {
1845 ($url) = $uri =~ m!([^/]+)$!;
1846 } elsif ($absolute) {
1847 $url = $uri;
1848 }
1849
1850 $url .= $path if $path_info and defined $path;
1851 $url .= "?$query_str" if $query and $query_str ne '';
1852 $url ||= '';
1853 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
1854 return $url;
1855}
1856
1857END_OF_FUNC
1858
1859#### Method: cookie
1860# Set or read a cookie from the specified name.
1861# Cookie can then be passed to header().
1862# Usual rules apply to the stickiness of -value.
1863# Parameters:
1864# -name -> name for this cookie (optional)
1865# -value -> value of this cookie (scalar, array or hash)
1866# -path -> paths for which this cookie is valid (optional)
1867# -domain -> internet domain in which this cookie is valid (optional)
1868# -secure -> if true, cookie only passed through secure channel (optional)
1869# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
1870####
1871'cookie' => <<'END_OF_FUNC',
1872sub cookie {
1873 my($self,@p) = self_or_default(@_);
1874 my($name,$value,$path,$domain,$secure,$expires,$httponly) =
1875 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
1876
1877 require CGI::Cookie;
1878
1879 # if no value is supplied, then we retrieve the
1880 # value of the cookie, if any. For efficiency, we cache the parsed
1881 # cookies in our state variables.
1882 unless ( defined($value) ) {
1883 $self->{'.cookies'} = CGI::Cookie->fetch;
1884
1885 # If no name is supplied, then retrieve the names of all our cookies.
1886 return () unless $self->{'.cookies'};
1887 return keys %{$self->{'.cookies'}} unless $name;
1888 return () unless $self->{'.cookies'}->{$name};
1889 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
1890 }
1891
1892 # If we get here, we're creating a new cookie
1893 return undef unless defined($name) && $name ne ''; # this is an error
1894
1895 my @param;
1896 push(@param,'-name'=>$name);
1897 push(@param,'-value'=>$value);
1898 push(@param,'-domain'=>$domain) if $domain;
1899 push(@param,'-path'=>$path) if $path;
1900 push(@param,'-expires'=>$expires) if $expires;
1901 push(@param,'-secure'=>$secure) if $secure;
1902 push(@param,'-httponly'=>$httponly) if $httponly;
1903
1904 return CGI::Cookie->new(@param);
1905}
1906END_OF_FUNC
1907
1908'parse_keywordlist' => <<'END_OF_FUNC',
1909sub parse_keywordlist {
1910 my($self,$tosplit) = @_;
1911 $tosplit = unescape($tosplit); # unescape the keywords
1912 $tosplit=~tr/+/ /; # pluses to spaces
1913 my(@keywords) = split(/\s+/,$tosplit);
1914 return @keywords;
1915}
1916END_OF_FUNC
1917
1918'param_fetch' => <<'END_OF_FUNC',
1919sub param_fetch {
1920 my($self,@p) = self_or_default(@_);
1921 my($name) = rearrange([NAME],@p);
1922 return [] unless defined $name;
1923
1924 unless (exists($self->{param}{$name})) {
1925 $self->add_parameter($name);
1926 $self->{param}{$name} = [];
1927 }
1928
1929 return $self->{param}{$name};
1930}
1931END_OF_FUNC
1932
1933###############################################
1934# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1935###############################################
1936
1937#### Method: path_info
1938# Return the extra virtual path information provided
1939# after the URL (if any)
1940####
1941'path_info' => <<'END_OF_FUNC',
1942sub path_info {
1943 my ($self,$info) = self_or_default(@_);
1944 if (defined($info)) {
1945 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
1946 $self->{'.path_info'} = $info;
1947 } elsif (! defined($self->{'.path_info'}) ) {
1948 my (undef,$path_info) = $self->_name_and_path_from_env;
1949 $self->{'.path_info'} = $path_info || '';
1950 }
1951 return $self->{'.path_info'};
1952}
1953END_OF_FUNC
1954
1955# This function returns a potentially modified version of SCRIPT_NAME
1956# and PATH_INFO. Some HTTP servers do sanitise the paths in those
1957# variables. It is the case of at least Apache 2. If for instance the
1958# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
1959# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
1960# SCRIPT_NAME=/path/to/env.cgi
1961# PATH_INFO=/x/y/x
1962#
1963# This is all fine except that some bogus CGI scripts expect
1964# PATH_INFO=/http://foo when the user requests
1965# http://xxx/script.cgi/http://foo
1966#
1967# Old versions of this module used to accomodate with those scripts, so
1968# this is why we do this here to keep those scripts backward compatible.
1969# Basically, we accomodate with those scripts but within limits, that is
1970# we only try to preserve the number of / that were provided by the user
1971# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
1972# of consecutive /.
1973#
1974# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
1975# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
1976# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
1977# possibly sanitised by the HTTP server, so in the case of Apache 2:
1978# script_name == /foo/x/z/script.cgi and path_info == /b/c.
1979#
1980# Future versions of this module may no longer do that, so one should
1981# avoid relying on the browser, proxy, server, and CGI.pm preserving the
1982# number of consecutive slashes as no guarantee can be made there.
1983'_name_and_path_from_env' => <<'END_OF_FUNC',
1984sub _name_and_path_from_env {
1985 my $self = shift;
1986 my $script_name = $ENV{SCRIPT_NAME} || '';
1987 my $path_info = $ENV{PATH_INFO} || '';
1988 my $uri = $self->request_uri || '';
1989
1990 $uri =~ s/\?.*//s;
1991 $uri = unescape($uri);
1992
1993 if ( $IIS ) {
1994 # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to
1995 # $ENV{SCRIPT_NAME}path_info
1996 # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do
1997 # the test below, hence this comes first
1998 $path_info =~ s/^\Q$script_name\E(.*)/$1/;
1999 } elsif ($uri ne "$script_name$path_info") {
2000 my $script_name_pattern = quotemeta($script_name);
2001 my $path_info_pattern = quotemeta($path_info);
2002 $script_name_pattern =~ s{(?:\\/)+}{/+}g;
2003 $path_info_pattern =~ s{(?:\\/)+}{/+}g;
2004
2005 if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
2006 # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
2007 # numer of consecutive slashes, so we can extract the info from
2008 # REQUEST_URI:
2009 ($script_name, $path_info) = ($1, $2);
2010 }
2011 }
2012 return ($script_name,$path_info);
2013}
2014END_OF_FUNC
2015
2016
2017#### Method: request_method
2018# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2019####
2020'request_method' => <<'END_OF_FUNC',
2021sub request_method {
2022 return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef;
2023}
2024END_OF_FUNC
2025
2026#### Method: content_type
2027# Returns the content_type string
2028####
2029'content_type' => <<'END_OF_FUNC',
2030sub content_type {
2031 return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef;
2032}
2033END_OF_FUNC
2034
2035#### Method: path_translated
2036# Return the physical path information provided
2037# by the URL (if any)
2038####
2039'path_translated' => <<'END_OF_FUNC',
2040sub path_translated {
2041 return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef;
2042}
2043END_OF_FUNC
2044
2045
2046#### Method: request_uri
2047# Return the literal request URI
2048####
2049'request_uri' => <<'END_OF_FUNC',
2050sub request_uri {
2051 return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef;
2052}
2053END_OF_FUNC
2054
2055
2056#### Method: query_string
2057# Synthesize a query string from our current
2058# parameters
2059####
2060'query_string' => <<'END_OF_FUNC',
2061sub query_string {
2062 my($self) = self_or_default(@_);
2063 my($param,$value,@pairs);
2064 for $param ($self->param) {
2065 my($eparam) = escape($param);
2066 for $value ($self->param($param)) {
2067 $value = escape($value);
2068 next unless defined $value;
2069 push(@pairs,"$eparam=$value");
2070 }
2071 }
2072 for (keys %{$self->{'.fieldnames'}}) {
2073 push(@pairs,".cgifields=".escape("$_"));
2074 }
2075 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2076}
2077END_OF_FUNC
2078
2079
2080#### Method: accept
2081# Without parameters, returns an array of the
2082# MIME types the browser accepts.
2083# With a single parameter equal to a MIME
2084# type, will return undef if the browser won't
2085# accept it, 1 if the browser accepts it but
2086# doesn't give a preference, or a floating point
2087# value between 0.0 and 1.0 if the browser
2088# declares a quantitative score for it.
2089# This handles MIME type globs correctly.
2090####
2091'Accept' => <<'END_OF_FUNC',
2092sub Accept {
2093 my($self,$search) = self_or_CGI(@_);
2094 my(%prefs,$type,$pref,$pat);
2095
2096 my(@accept) = defined $self->http('accept')
2097 ? split(',',$self->http('accept'))
2098 : ();
2099
2100 for (@accept) {
2101 ($pref) = /q=(\d\.\d+|\d+)/;
2102 ($type) = m#(\S+/[^;]+)#;
2103 next unless $type;
2104 $prefs{$type}=$pref || 1;
2105 }
2106
2107 return keys %prefs unless $search;
2108
2109 # if a search type is provided, we may need to
2110 # perform a pattern matching operation.
2111 # The MIME types use a glob mechanism, which
2112 # is easily translated into a perl pattern match
2113
2114 # First return the preference for directly supported
2115 # types:
2116 return $prefs{$search} if $prefs{$search};
2117
2118 # Didn't get it, so try pattern matching.
2119 for (keys %prefs) {
2120 next unless /\*/; # not a pattern match
2121 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2122 $pat =~ s/\*/.*/g; # turn it into a pattern
2123 return $prefs{$_} if $search=~/$pat/;
2124 }
2125}
2126END_OF_FUNC
2127
2128
2129#### Method: user_agent
2130# If called with no parameters, returns the user agent.
2131# If called with one parameter, does a pattern match (case
2132# insensitive) on the user agent.
2133####
2134'user_agent' => <<'END_OF_FUNC',
2135sub user_agent {
2136 my($self,$match)=self_or_CGI(@_);
2137 my $user_agent = $self->http('user_agent');
2138 return $user_agent unless defined $match && $match && $user_agent;
2139 return $user_agent =~ /$match/i;
2140}
2141END_OF_FUNC
2142
2143
2144#### Method: raw_cookie
2145# Returns the magic cookies for the session.
2146# The cookies are not parsed or altered in any way, i.e.
2147# cookies are returned exactly as given in the HTTP
2148# headers. If a cookie name is given, only that cookie's
2149# value is returned, otherwise the entire raw cookie
2150# is returned.
2151####
2152'raw_cookie' => <<'END_OF_FUNC',
2153sub raw_cookie {
2154 my($self,$key) = self_or_CGI(@_);
2155
2156 require CGI::Cookie;
2157
2158 if (defined($key)) {
2159 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2160 unless $self->{'.raw_cookies'};
2161
2162 return () unless $self->{'.raw_cookies'};
2163 return () unless $self->{'.raw_cookies'}->{$key};
2164 return $self->{'.raw_cookies'}->{$key};
2165 }
2166 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2167}
2168END_OF_FUNC
2169
2170#### Method: virtual_host
2171# Return the name of the virtual_host, which
2172# is not always the same as the server
2173######
2174'virtual_host' => <<'END_OF_FUNC',
2175sub virtual_host {
2176 my $vh = http('x_forwarded_host') || http('host') || server_name();
2177 $vh =~ s/:\d+$//; # get rid of port number
2178 return $vh;
2179}
2180END_OF_FUNC
2181
2182#### Method: remote_host
2183# Return the name of the remote host, or its IP
2184# address if unavailable. If this variable isn't
2185# defined, it returns "localhost" for debugging
2186# purposes.
2187####
2188'remote_host' => <<'END_OF_FUNC',
2189sub remote_host {
2190 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2191 || 'localhost';
2192}
2193END_OF_FUNC
2194
2195
2196#### Method: remote_addr
2197# Return the IP addr of the remote host.
2198####
2199'remote_addr' => <<'END_OF_FUNC',
2200sub remote_addr {
2201 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2202}
2203END_OF_FUNC
2204
2205
2206#### Method: script_name
2207# Return the partial URL to this script for
2208# self-referencing scripts. Also see
2209# self_url(), which returns a URL with all state information
2210# preserved.
2211####
2212'script_name' => <<'END_OF_FUNC',
2213sub script_name {
2214 my ($self,@p) = self_or_default(@_);
2215 if (@p) {
2216 $self->{'.script_name'} = shift @p;
2217 } elsif (!exists $self->{'.script_name'}) {
2218 my ($script_name,$path_info) = $self->_name_and_path_from_env();
2219 $self->{'.script_name'} = $script_name;
2220 }
2221 return $self->{'.script_name'};
2222}
2223END_OF_FUNC
2224
2225
2226#### Method: referer
2227# Return the HTTP_REFERER: useful for generating
2228# a GO BACK button.
2229####
2230'referer' => <<'END_OF_FUNC',
2231sub referer {
2232 my($self) = self_or_CGI(@_);
2233 return $self->http('referer');
2234}
2235END_OF_FUNC
2236
2237
2238#### Method: server_name
2239# Return the name of the server
2240####
2241'server_name' => <<'END_OF_FUNC',
2242sub server_name {
2243 return $ENV{'SERVER_NAME'} || 'localhost';
2244}
2245END_OF_FUNC
2246
2247#### Method: server_software
2248# Return the name of the server software
2249####
2250'server_software' => <<'END_OF_FUNC',
2251sub server_software {
2252 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2253}
2254END_OF_FUNC
2255
2256#### Method: virtual_port
2257# Return the server port, taking virtual hosts into account
2258####
2259'virtual_port' => <<'END_OF_FUNC',
2260sub virtual_port {
2261 my($self) = self_or_default(@_);
2262 my $vh = $self->http('x_forwarded_host') || $self->http('host');
2263 my $protocol = $self->protocol;
2264 if ($vh) {
2265 return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
2266 } else {
2267 return $self->server_port();
2268 }
2269}
2270END_OF_FUNC
2271
2272#### Method: server_port
2273# Return the tcp/ip port the server is running on
2274####
2275'server_port' => <<'END_OF_FUNC',
2276sub server_port {
2277 return $ENV{'SERVER_PORT'} || 80; # for debugging
2278}
2279END_OF_FUNC
2280
2281#### Method: server_protocol
2282# Return the protocol (usually HTTP/1.0)
2283####
2284'server_protocol' => <<'END_OF_FUNC',
2285sub server_protocol {
2286 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2287}
2288END_OF_FUNC
2289
2290#### Method: http
2291# Return the value of an HTTP variable, or
2292# the list of variables if none provided
2293####
2294'http' => <<'END_OF_FUNC',
2295sub http {
2296 my ($self,$parameter) = self_or_CGI(@_);
2297 if ( defined($parameter) ) {
2298 $parameter =~ tr/-a-z/_A-Z/;
2299 if ( $parameter =~ /^HTTP(?:_|$)/ ) {
2300 return $ENV{$parameter};
2301 }
2302 return $ENV{"HTTP_$parameter"};
2303 }
2304 return grep { /^HTTP(?:_|$)/ } keys %ENV;
2305}
2306END_OF_FUNC
2307
2308#### Method: https
2309# Return the value of HTTPS, or
2310# the value of an HTTPS variable, or
2311# the list of variables
2312####
2313'https' => <<'END_OF_FUNC',
2314sub https {
2315 my ($self,$parameter) = self_or_CGI(@_);
2316 if ( defined($parameter) ) {
2317 $parameter =~ tr/-a-z/_A-Z/;
2318 if ( $parameter =~ /^HTTPS(?:_|$)/ ) {
2319 return $ENV{$parameter};
2320 }
2321 return $ENV{"HTTPS_$parameter"};
2322 }
2323 return wantarray
2324 ? grep { /^HTTPS(?:_|$)/ } keys %ENV
2325 : $ENV{'HTTPS'};
2326}
2327END_OF_FUNC
2328
2329#### Method: protocol
2330# Return the protocol (http or https currently)
2331####
2332'protocol' => <<'END_OF_FUNC',
2333sub protocol {
2334 local($^W)=0;
2335 my $self = shift;
2336 return 'https' if uc($self->https()) eq 'ON';
2337 return 'https' if $self->server_port == 443;
2338 my $prot = $self->server_protocol;
2339 my($protocol,$version) = split('/',$prot);
2340 return "\L$protocol\E";
2341}
2342END_OF_FUNC
2343
2344#### Method: remote_ident
2345# Return the identity of the remote user
2346# (but only if his host is running identd)
2347####
2348'remote_ident' => <<'END_OF_FUNC',
2349sub remote_ident {
2350 return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef;
2351}
2352END_OF_FUNC
2353
2354
2355#### Method: auth_type
2356# Return the type of use verification/authorization in use, if any.
2357####
2358'auth_type' => <<'END_OF_FUNC',
2359sub auth_type {
2360 return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef;
2361}
2362END_OF_FUNC
2363
2364
2365#### Method: remote_user
2366# Return the authorization name used for user
2367# verification.
2368####
2369'remote_user' => <<'END_OF_FUNC',
2370sub remote_user {
2371 return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef;
2372}
2373END_OF_FUNC
2374
2375
2376#### Method: user_name
2377# Try to return the remote user's name by hook or by
2378# crook
2379####
2380'user_name' => <<'END_OF_FUNC',
2381sub user_name {
2382 my ($self) = self_or_CGI(@_);
2383 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2384}
2385END_OF_FUNC
2386
2387#### Method: nosticky
2388# Set or return the NOSTICKY global flag
2389####
2390'nosticky' => <<'END_OF_FUNC',
2391sub nosticky {
2392 my ($self,$param) = self_or_CGI(@_);
2393 $CGI::NOSTICKY = $param if defined($param);
2394 return $CGI::NOSTICKY;
2395}
2396END_OF_FUNC
2397
2398#### Method: nph
2399# Set or return the NPH global flag
2400####
2401'nph' => <<'END_OF_FUNC',
2402sub nph {
2403 my ($self,$param) = self_or_CGI(@_);
2404 $CGI::NPH = $param if defined($param);
2405 return $CGI::NPH;
2406}
2407END_OF_FUNC
2408
2409#### Method: private_tempfiles
2410# Set or return the private_tempfiles global flag
2411####
2412'private_tempfiles' => <<'END_OF_FUNC',
2413sub private_tempfiles {
2414 warn "private_tempfiles has been deprecated";
2415 return 0;
2416}
2417END_OF_FUNC
2418#### Method: close_upload_files
2419# Set or return the close_upload_files global flag
2420####
2421'close_upload_files' => <<'END_OF_FUNC',
2422sub close_upload_files {
2423 my ($self,$param) = self_or_CGI(@_);
2424 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
2425 return $CGI::CLOSE_UPLOAD_FILES;
2426}
2427END_OF_FUNC
2428
2429
2430#### Method: default_dtd
2431# Set or return the default_dtd global
2432####
2433'default_dtd' => <<'END_OF_FUNC',
2434sub default_dtd {
2435 my ($self,$param,$param2) = self_or_CGI(@_);
2436 if (defined $param2 && defined $param) {
2437 $CGI::DEFAULT_DTD = [ $param, $param2 ];
2438 } elsif (defined $param) {
2439 $CGI::DEFAULT_DTD = $param;
2440 }
2441 return $CGI::DEFAULT_DTD;
2442}
2443END_OF_FUNC
2444
2445# -------------- really private subroutines -----------------
2446'_maybe_escapeHTML' => <<'END_OF_FUNC',
2447sub _maybe_escapeHTML {
2448 # hack to work around earlier hacks
2449 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2450 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
2451 return undef unless defined($toencode);
2452 return $toencode if ref($self) && !$self->{'escape'};
2453 return $self->escapeHTML($toencode, $newlinestoo);
2454}
2455END_OF_FUNC
2456
2457'previous_or_default' => <<'END_OF_FUNC',
2458sub previous_or_default {
2459 my($self,$name,$defaults,$override) = @_;
2460 my(%selected);
2461
2462 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2463 defined($self->param($name)) ) ) {
2464 $selected{$_}++ for $self->param($name);
2465 } elsif (defined($defaults) && ref($defaults) &&
2466 (ref($defaults) eq 'ARRAY')) {
2467 $selected{$_}++ for @{$defaults};
2468 } else {
2469 $selected{$defaults}++ if defined($defaults);
2470 }
2471
2472 return %selected;
2473}
2474END_OF_FUNC
2475
2476'register_parameter' => <<'END_OF_FUNC',
2477sub register_parameter {
2478 my($self,$param) = @_;
2479 $self->{'.parametersToAdd'}->{$param}++;
2480}
2481END_OF_FUNC
2482
2483'get_fields' => <<'END_OF_FUNC',
2484sub get_fields {
2485 my($self) = @_;
2486 return $self->CGI::hidden('-name'=>'.cgifields',
2487 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2488 '-override'=>1);
2489}
2490END_OF_FUNC
2491
2492'read_from_cmdline' => <<'END_OF_FUNC',
2493sub read_from_cmdline {
2494 my($input,@words);
2495 my($query_string);
2496 my($subpath);
2497 if ($DEBUG && @ARGV) {
2498 @words = @ARGV;
2499 } elsif ($DEBUG > 1) {
2500 require Text::ParseWords;
2501 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
2502 chomp(@lines = <STDIN>); # remove newlines
2503 $input = join(" ",@lines);
2504 @words = &Text::ParseWords::old_shellwords($input);
2505 }
2506 for (@words) {
2507 s/\\=/%3D/g;
2508 s/\\&/%26/g;
2509 }
2510
2511 if ("@words"=~/=/) {
2512 $query_string = join('&',@words);
2513 } else {
2514 $query_string = join('+',@words);
2515 }
2516 if ($query_string =~ /^(.*?)\?(.*)$/)
2517 {
2518 $query_string = $2;
2519 $subpath = $1;
2520 }
2521 return { 'query_string' => $query_string, 'subpath' => $subpath };
2522}
2523END_OF_FUNC
2524
2525#####
2526# subroutine: read_multipart
2527#
2528# Read multipart data and store it into our parameters.
2529# An interesting feature is that if any of the parts is a file, we
2530# create a temporary file and open up a filehandle on it so that the
2531# caller can read from it if necessary.
2532#####
2533'read_multipart' => <<'END_OF_FUNC',
2534sub read_multipart {
2535 my($self,$boundary,$length) = @_;
2536 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2537 return unless $buffer;
2538 my(%header,$body);
2539 my $filenumber = 0;
2540 while (!$buffer->eof) {
2541 %header = $buffer->readHeader;
2542
2543 unless (%header) {
2544 $self->cgi_error("400 Bad request (malformed multipart POST)");
2545 return;
2546 }
2547
2548 $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
2549
2550 my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/;
2551 $param .= $TAINTED;
2552
2553 # See RFC 1867, 2183, 2045
2554 # NB: File content will be loaded into memory should
2555 # content-disposition parsing fail.
2556 my ($filename) = $header{'Content-Disposition'}
2557 =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
2558
2559 $filename ||= ''; # quench uninit variable warning
2560
2561 $filename =~ s/^"([^"]*)"$/$1/;
2562 # Test for Opera's multiple upload feature
2563 my($multipart) = ( defined( $header{'Content-Type'} ) &&
2564 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
2565 1 : 0;
2566
2567 # add this parameter to our list
2568 $self->add_parameter($param);
2569
2570 # If no filename specified, then just read the data and assign it
2571 # to our parameter list.
2572 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
2573 my($value) = $buffer->readBody;
2574 $value .= $TAINTED;
2575 push(@{$self->{param}{$param}},$value);
2576 next;
2577 }
2578
2579 UPLOADS: {
2580 # If we get here, then we are dealing with a potentially large
2581 # uploaded form. Save the data to a temporary file, then open
2582 # the file for reading.
2583
2584 # skip the file if uploads disabled
2585 if ($DISABLE_UPLOADS) {
2586 while (defined($data = $buffer->read)) { }
2587 last UPLOADS;
2588 }
2589
2590 # set the filename to some recognizable value
2591 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
2592 $filename = "multipart/mixed";
2593 }
2594
2595 my $tmp_dir = $CGI::OS eq 'WINDOWS'
2596 ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) )
2597 : undef; # File::Temp defaults to TMPDIR
2598
2599 my $filehandle = CGI::File::Temp->new(
2600 UNLINK => $UNLINK_TMP_FILES,
2601 DIR => $tmp_dir,
2602 );
2603 $filehandle->_mp_filename( $filename );
2604
2605 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
2606 && defined fileno($filehandle);
2607
2608 # if this is an multipart/mixed attachment, save the header
2609 # together with the body for later parsing with an external
2610 # MIME parser module
2611 if ( $multipart ) {
2612 for ( keys %header ) {
2613 print $filehandle "$_: $header{$_}${CRLF}";
2614 }
2615 print $filehandle "${CRLF}";
2616 }
2617
2618 my ($data);
2619 local($\) = '';
2620 my $totalbytes = 0;
2621 while (defined($data = $buffer->read)) {
2622 if (defined $self->{'.upload_hook'})
2623 {
2624 $totalbytes += length($data);
2625 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
2626 }
2627 print $filehandle $data if ($self->{'use_tempfile'});
2628 }
2629
2630 # back up to beginning of file
2631 seek($filehandle,0,0);
2632
2633 ## Close the filehandle if requested this allows a multipart MIME
2634 ## upload to contain many files, and we won't die due to too many
2635 ## open file handles. The user can access the files using the hash
2636 ## below.
2637 close $filehandle if $CLOSE_UPLOAD_FILES;
2638 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2639
2640 # Save some information about the uploaded file where we can get
2641 # at it later.
2642 # Use the typeglob + filename as the key, as this is guaranteed to be
2643 # unique for each filehandle. Don't use the file descriptor as
2644 # this will be re-used for each filehandle if the
2645 # close_upload_files feature is used.
2646 $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = {
2647 hndl => $filehandle,
2648 name => $filehandle->filename,
2649 info => {%header},
2650 };
2651 push(@{$self->{param}{$param}},$filehandle);
2652 }
2653 }
2654}
2655END_OF_FUNC
2656
2657#####
2658# subroutine: read_multipart_related
2659#
2660# Read multipart/related data and store it into our parameters. The
2661# first parameter sets the start of the data. The part identified by
2662# this Content-ID will not be stored as a file upload, but will be
2663# returned by this method. All other parts will be available as file
2664# uploads accessible by their Content-ID
2665#####
2666'read_multipart_related' => <<'END_OF_FUNC',
2667sub read_multipart_related {
2668 my($self,$start,$boundary,$length) = @_;
2669 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2670 return unless $buffer;
2671 my(%header,$body);
2672 my $filenumber = 0;
2673 my $returnvalue;
2674 while (!$buffer->eof) {
2675 %header = $buffer->readHeader;
2676
2677 unless (%header) {
2678 $self->cgi_error("400 Bad request (malformed multipart POST)");
2679 return;
2680 }
2681
2682 my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
2683 $param .= $TAINTED;
2684
2685 # If this is the start part, then just read the data and assign it
2686 # to our return variable.
2687 if ( $param eq $start ) {
2688 $returnvalue = $buffer->readBody;
2689 $returnvalue .= $TAINTED;
2690 next;
2691 }
2692
2693 # add this parameter to our list
2694 $self->add_parameter($param);
2695
2696 UPLOADS: {
2697 # If we get here, then we are dealing with a potentially large
2698 # uploaded form. Save the data to a temporary file, then open
2699 # the file for reading.
2700
2701 # skip the file if uploads disabled
2702 if ($DISABLE_UPLOADS) {
2703 while (defined($data = $buffer->read)) { }
2704 last UPLOADS;
2705 }
2706
2707 my $tmp_dir = $CGI::OS eq 'WINDOWS'
2708 ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) )
2709 : undef; # File::Temp defaults to TMPDIR
2710
2711 my $filehandle = CGI::File::Temp->new(
2712 UNLINK => $UNLINK_TMP_FILES,
2713 DIR => $tmp_dir,
2714 );
2715 $filehandle->_mp_filename( $filehandle->filename );
2716
2717 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
2718 && defined fileno($filehandle);
2719
2720 my ($data);
2721 local($\) = '';
2722 my $totalbytes;
2723 while (defined($data = $buffer->read)) {
2724 if (defined $self->{'.upload_hook'})
2725 {
2726 $totalbytes += length($data);
2727 &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
2728 }
2729 print $filehandle $data if ($self->{'use_tempfile'});
2730 }
2731
2732 # back up to beginning of file
2733 seek($filehandle,0,0);
2734
2735 ## Close the filehandle if requested this allows a multipart MIME
2736 ## upload to contain many files, and we won't die due to too many
2737 ## open file handles. The user can access the files using the hash
2738 ## below.
2739 close $filehandle if $CLOSE_UPLOAD_FILES;
2740 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2741
2742 # Save some information about the uploaded file where we can get
2743 # at it later.
2744 # Use the typeglob + filename as the key, as this is guaranteed to be
2745 # unique for each filehandle. Don't use the file descriptor as
2746 # this will be re-used for each filehandle if the
2747 # close_upload_files feature is used.
2748 $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = {
2749 hndl => $filehandle,
2750 name => $filehandle->filename,
2751 info => {%header},
2752 };
2753 push(@{$self->{param}{$param}},$filehandle);
2754 }
2755 }
2756 return $returnvalue;
2757}
2758END_OF_FUNC
2759
2760
2761'upload' =><<'END_OF_FUNC',
2762sub upload {
2763 my($self,$param_name) = self_or_default(@_);
2764 my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
2765 return unless @param;
2766 return wantarray ? @param : $param[0];
2767}
2768END_OF_FUNC
2769
2770'tmpFileName' => <<'END_OF_FUNC',
2771sub tmpFileName {
2772 my($self,$filename) = self_or_default(@_);
2773 return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || '';
2774}
2775END_OF_FUNC
2776
2777'uploadInfo' => <<'END_OF_FUNC',
2778sub uploadInfo {
2779 my($self,$filename) = self_or_default(@_);
2780 return if ! defined $$filename;
2781 return $self->{'.tmpfiles'}->{$$filename . $filename}->{info};
2782}
2783END_OF_FUNC
2784
2785# internal routine, don't use
2786'_set_values_and_labels' => <<'END_OF_FUNC',
2787sub _set_values_and_labels {
2788 my $self = shift;
2789 my ($v,$l,$n) = @_;
2790 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2791 return $self->param($n) if !defined($v);
2792 return $v if !ref($v);
2793 return ref($v) eq 'HASH' ? keys %$v : @$v;
2794}
2795END_OF_FUNC
2796
2797# internal routine, don't use
2798'_set_attributes' => <<'END_OF_FUNC',
2799sub _set_attributes {
2800 my $self = shift;
2801 my($element, $attributes) = @_;
2802 return '' unless defined($attributes->{$element});
2803 $attribs = ' ';
2804 for my $attrib (keys %{$attributes->{$element}}) {
2805 (my $clean_attrib = $attrib) =~ s/^-//;
2806 $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
2807 }
2808 $attribs =~ s/ $//;
2809 return $attribs;
2810}
2811END_OF_FUNC
2812
2813'_compile_all' => <<'END_OF_FUNC',
2814sub _compile_all {
2815 for (@_) {
2816 next if defined(&$_);
2817 $AUTOLOAD = "CGI::$_";
2818 _compile();
2819 }
2820}
2821END_OF_FUNC
2822
2823);
2824
2825;